home *** CD-ROM | disk | FTP | other *** search
/ isnet Internet / Isnet Internet CD.iso / prog / hiz / 09 / 09.exe / adynware.exe / perl / lib / site / LWP / Protocol / ftp.pm < prev    next >
Encoding:
Perl POD Document  |  1999-12-28  |  7.1 KB  |  253 lines
  1.  
  2.  
  3. package LWP::Protocol::ftp;
  4.  
  5. use Carp ();
  6.  
  7. use HTTP::Status ();
  8. use HTTP::Negotiate ();
  9. use HTTP::Response ();
  10. use LWP::MediaTypes ();
  11. use File::Listing ();
  12.  
  13. require LWP::Protocol;
  14. @ISA = qw(LWP::Protocol);
  15.  
  16. use strict;
  17. eval {
  18.     require Net::FTP;
  19.     Net::FTP->require_version(2.00);
  20. };
  21. my $init_failed = $@;
  22.  
  23.  
  24. sub request
  25. {
  26.     my($self, $request, $proxy, $arg, $size, $timeout) = @_;
  27.  
  28.     $size = 4096 unless $size;
  29.  
  30.     LWP::Debug::trace('()');
  31.  
  32.     if (defined $proxy)
  33.     {
  34.     return new HTTP::Response &HTTP::Status::RC_BAD_REQUEST,
  35.                   'You can not proxy through the ftp';
  36.     }
  37.  
  38.     my $url = $request->url;
  39.     if ($url->scheme ne 'ftp') {
  40.     my $scheme = $url->scheme;
  41.     return new HTTP::Response &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
  42.                "LWP::Protocol::ftp::request called for '$scheme'";
  43.     }
  44.  
  45.     my $method = $request->method;
  46.  
  47.     unless ($method eq 'GET' || $method eq 'HEAD' || $method eq 'PUT') {
  48.     return new HTTP::Response &HTTP::Status::RC_BAD_REQUEST,
  49.                   'Library does not allow method ' .
  50.                   "$method for 'ftp:' URLs";
  51.     }
  52.  
  53.     if ($init_failed) {
  54.     return new HTTP::Response &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
  55.                $init_failed;
  56.     }
  57.  
  58.     my $host     = $url->host;
  59.     my $port     = $url->port;
  60.     my $user     = $url->user;
  61.     my $password = $url->password;
  62.  
  63.     {
  64.     my($u,$p) = $request->authorization_basic;
  65.     if (defined $u) {
  66.         $user = $u;
  67.         $password = $p;
  68.     }
  69.     }
  70.  
  71.     my $acct     = $request->header('Account');
  72.  
  73.     my $response = new HTTP::Response &HTTP::Status::RC_OK, "Document follows";
  74.     $response->request($request);
  75.  
  76.     my $ftp = new Net::FTP $host, Port => $port;
  77.     my $mess = $ftp->message;  # welcome message
  78.     LWP::Debug::debug($mess);
  79.     $mess =~ s|\n.*||s; # only first line left
  80.     $mess =~ s|\s*ready\.?$||;
  81.     $mess =~ s|\s*\(Version\s*|/| and $mess =~ s|\)$||;
  82.     $response->header("Server", $mess);
  83.  
  84.     $ftp->timeout($timeout) if $timeout;
  85.  
  86.     LWP::Debug::debug("Logging in as $user (password $password)...");
  87.     unless ($ftp->login($user, $password, $acct)) {
  88.     my $res =  new HTTP::Response &HTTP::Status::RC_UNAUTHORIZED, $ftp->message;
  89.     $res->header("WWW-Authenticate", qq(Basic Realm="FTP login"));
  90.     return $res;
  91.     }
  92.     LWP::Debug::debug($ftp->message);
  93.  
  94.     my @path =  $url->path_components;
  95.     shift(@path);  # There will always be an empty first component
  96.     pop(@path) while @path && $path[-1] eq '';  # remove empty tailing comps
  97.     my $remote_file = pop(@path);
  98.     $remote_file = '' unless defined $remote_file;
  99.  
  100.     my $params = $url->params;
  101.     if (defined($params) && $params eq 'type=a') {
  102.     $ftp->ascii;
  103.     } else {
  104.     $ftp->binary;
  105.     }
  106.  
  107.     for (@path) {
  108.     LWP::Debug::debug("CWD $_");
  109.     unless ($ftp->cwd($_)) {
  110.         return new HTTP::Response &HTTP::Status::RC_NOT_FOUND,
  111.                "Can't chdir to $_";
  112.     }
  113.     }
  114.  
  115.     if ($method eq 'GET' || $method eq 'HEAD') {
  116.     my $data;  # the data handle
  117.     LWP::Debug::debug("retrieve file?");
  118.     if (length($remote_file) and $data = $ftp->retr($remote_file)) {
  119.         my($type, @enc) = LWP::MediaTypes::guess_media_type($remote_file);
  120.         $response->header('Content-Type',   $type) if $type;
  121.         for (@enc) {
  122.         $response->push_header('Content-Encoding', $_);
  123.         }
  124.         my $mess = $ftp->message;
  125.         LWP::Debug::debug($mess);
  126.         if ($mess =~ /\((\d+)\s+bytes\)/) {
  127.         $response->header('Content-Length', "$1");
  128.         }
  129.  
  130.         if ($method ne 'HEAD') {
  131.         $response = $self->collect($arg, $response, sub {
  132.             my $content = '';
  133.             my $result = $data->read($content, $size);
  134.             return \$content;
  135.         } );
  136.         }
  137.         unless ($data->close) {
  138.         if ($method ne 'HEAD') {
  139.             $response->code(&HTTP::Status::RC_INTERNAL_SERVER_ERROR);
  140.             $response->message("FTP close response: " . $ftp->code .
  141.                        " " . $ftp->message);
  142.         }
  143.         }
  144.     } elsif (!length($remote_file) || $ftp->code == 550) {
  145.         if (length($remote_file) && !$ftp->cwd($remote_file)) {
  146.         LWP::Debug::debug("chdir before listing failed");
  147.         return new HTTP::Response &HTTP::Status::RC_NOT_FOUND,
  148.                "File '$remote_file' not found";
  149.         }
  150.  
  151.         LWP::Debug::debug("dir");
  152.         my @lsl = $ftp->dir;
  153.  
  154.         my @variants =
  155.           (
  156.            ['html',  0.60, 'text/html'            ],
  157.            ['dir',   1.00, 'text/ftp-dir-listing' ]
  158.           );
  159.         my $prefer = HTTP::Negotiate::choose(\@variants, $request);
  160.  
  161.         my $content = '';
  162.  
  163.         if (!defined($prefer)) {
  164.         return new HTTP::Response &HTTP::Status::RC_NOT_ACCEPTABLE,
  165.                    "Neither HTML nor directory listing wanted";
  166.         } elsif ($prefer eq 'html') {
  167.         $response->header('Content-Type' => 'text/html');
  168.         $content = "<HEAD><TITLE>File Listing</TITLE>\n";
  169.         my $base = $request->url->clone;
  170.         my $path = $base->epath;
  171.         $base->epath("$path/") unless $path =~ m|/$|;
  172.         $content .= qq(<BASE HREF="$base">\n</HEAD>\n);
  173.         $content .= "<BODY>\n<UL>\n";
  174.         for (File::Listing::parse_dir(\@lsl, 'GMT')) {
  175.             my($name, $type, $size, $mtime, $mode) = @$_;
  176.             $content .= qq(  <LI> <a href="$name">$name</a>);
  177.             $content .= " $size bytes" if $type eq 'f';
  178.             $content .= "\n";
  179.         }
  180.         $content .= "</UL></body>\n";
  181.         } else {
  182.         $response->header('Content-Type', 'text/ftp-dir-listing');
  183.         $content = join("\n", @lsl, '');
  184.         }
  185.  
  186.         $response->header('Content-Length', length($content));
  187.  
  188.         if ($method ne 'HEAD') {
  189.         $response = $self->collect_once($arg, $response, $content);
  190.         }
  191.     } else {
  192.         my $res = new HTTP::Response &HTTP::Status::RC_BAD_REQUEST,
  193.               "FTP return code " . $ftp->code;
  194.         $res->content_type("text/plain");
  195.         $res->content($ftp->message);
  196.         return $res;
  197.     }
  198.     } elsif ($method eq 'PUT') {
  199.     unless (length($remote_file)) {
  200.         return new HTTP::Response &HTTP::Status::RC_BAD_REQUEST,
  201.                       "Must have a file name to PUT to";
  202.     }
  203.     my $data;
  204.     if ($data = $ftp->stor($remote_file)) {
  205.         LWP::Debug::debug($ftp->message);
  206.         LWP::Debug::debug("$data");
  207.         my $content = $request->content;
  208.         my $bytes = 0;
  209.         if (defined $content) {
  210.         if (ref($content) eq 'SCALAR') {
  211.             $bytes = $data->write($$content, length($$content));
  212.         } elsif (ref($content) eq 'CODE') {
  213.             my($buf, $n);
  214.             while (length($buf = &$content)) {
  215.             $n = $data->write($buf, length($buf));
  216.             last unless $n;
  217.             $bytes += $n;
  218.             }
  219.         } elsif (!ref($content)) {
  220.             if (defined $content && length($content)) {
  221.             $bytes = $data->write($content, length($content));
  222.             }
  223.         } else {
  224.             die "Bad content";
  225.         }
  226.         }
  227.         $data->close;
  228.         LWP::Debug::debug($ftp->message);
  229.  
  230.         $response->code(&HTTP::Status::RC_CREATED);
  231.         $response->header('Content-Type', 'text/plain');
  232.         $response->content("$bytes bytes stored as $remote_file on $host\n")
  233.  
  234.     } else {
  235.         my $res = new HTTP::Response &HTTP::Status::RC_BAD_REQUEST,
  236.               "FTP return code " . $ftp->code;
  237.         $res->content_type("text/plain");
  238.         $res->content($ftp->message);
  239.         return $res;
  240.     }
  241.     } else {
  242.     return new HTTP::Response &HTTP::Status::RC_BAD_REQUEST,
  243.            "Illegal method $method"
  244.     }
  245.  
  246.     $response;
  247. }
  248.  
  249. 1;
  250.  
  251. __END__
  252.  
  253.